home *** CD-ROM | disk | FTP | other *** search
/ MacTech 1 to 12 / MacTech-vol-1-12.toast / Source / MacTech® Magazine / Volume 06 - 1990 / 06.08 Aug 90 / Pearl Source / Solar.lisp (Edit) next >
Encoding:
Text File  |  1988-06-12  |  9.7 KB  |  274 lines  |  [TEXT/EDIT]
  1.  
  2. ;;; Sample program for "Objects in Pearl Lisp"
  3. ;;; by Stephen E. Miner
  4. ;;; Written in Pearl Lisp 1.01
  5. ;;; File:  Solar.lisp
  6. ;;; Version: 1.0
  7.  
  8.  
  9. ;;; NOTE:  The "object-variable" declarations prevent the 
  10. ;;;compiler from issuing warnings about free variables.
  11.  
  12.  
  13. ;;; Set up environment
  14. (eval-when (eval load compile)
  15.   (require 'quickdraw))
  16. (eval-when (eval compile)
  17.   (require 'records))
  18.  
  19.  
  20. ;;; Global variables
  21. (defvar *solar-num* 0 "Global counter for numbering     windows.")
  22. (defvar *time* 0 "Global variable holding the time that is     displayed.")
  23. (defvar *stop-flag* t "Non-nil if the simulation should stop.")
  24.  
  25.  
  26. ;;; The planet class
  27. (defobject *planet* nil)
  28.  
  29. (defobfun (exist *planet*) (init-list)
  30.   "Initializes an instance of the *planet* class according to 
  31.   INIT-LIST.   Useful init keywords are :period, :size, :pattern, 
  32.   :radius and :center.   The return value is undefined."
  33.   (have 'period (getf init-list :period 25))
  34.   (have 'size (getf init-list :size 3))
  35.   (have 'pattern (getf init-list :pattern *black-pattern*))
  36.   (have 'x 0)
  37.   (have 'y 0)
  38.   (have 'satellites nil)
  39.   (let ((center (getf init-list :center))
  40.            (me (self)))           ;(self) returns the object being defined
  41.       (have 'radius (getf init-list :radius (if center 25 0)))
  42.       (when center
  43.          (ask center (add-satellite me)))))
  44.  
  45. (defobfun (add-satellite *planet*) (sat)
  46.   "Add SAT to the planet's list of satellites and return the new
  47.   list."
  48.   (declare (object-variable satellites))
  49.   (setq satellites (cons sat satellites)))
  50.  
  51. (defobfun (update-system *planet*) (time cx cy)
  52.   "Update the x and y coordinates of the planet according to the 
  53.   TIME and the offsets CX and CY which should be the x and y 
  54.   coordinates of the center of the planet's orbit.  Then recursively 
  55.   send the update-system message to the satellites of the planet
  56.   using the new x and y coordinates as the offsets.  The return 
  57.   value is undefined." 
  58.   (declare (object-variable period radius x y satellites))
  59.   (let* ((theta (* 2 pi (/ time period)))
  60.              (new-x (+ cx (round (* radius (cos theta)))))
  61.              (new-y (+ cy (round (* radius (sin theta))))))
  62.       (setq x new-x y new-y)
  63.       (dolist (sat satellites)
  64.           (ask sat (update-system time new-x new-y)))))
  65.  
  66.  
  67.  
  68. ;;; The planet objects (the numbers are not accurate, but they 
  69. ;;; produce a reasonable display.)
  70.  
  71. (defparameter *sun* (oneof *planet* :center nil :size 11 
  72.                            :pattern *light-gray-pattern*))
  73.   
  74. (defparameter *mercury* (oneof *planet* :radius 20 :center     
  75.     *sun* :period 12  :size 3 :pattern     
  76.     *dark-gray-pattern*))
  77.  
  78. (defparameter *venus* (oneof *planet* :radius 35 :center 
  79.     *sun* :period 32 :size 5 :pattern
  80.      *dark-gray-pattern*))
  81.  
  82. (defparameter *earth* (oneof *planet* :radius 60 :center *sun*     
  83.     :period 52 :size 6 :pattern *gray-pattern*))
  84.  
  85. (defparameter *moon* (oneof *planet* :radius 10 :center     
  86.     *earth* :period 4  :size 2))
  87.  
  88. (defparameter *mars* (oneof *planet* :radius 85 :center *sun*     
  89.     :period 90 :size 5 :pattern *dark-gray-pattern*))
  90.  
  91.  
  92.  
  93. ;;; The solar window class
  94. (defobject *solar-window* *window*)
  95.  
  96. (defobfun (exist *solar-window*) (init-list)
  97.   "Initializes an instance of the *solar-window* according to 
  98.   the INIT-LIST.  Useful keywords are :center which specifies 
  99.   the gravitational center of the displayed system and :view
  100.   which specifies the planet that controls the viewpoint of the 
  101.   display.  The return value is undefined."
  102.   (declare (object-variable center))
  103.   (usual-exist (init-list-default init-list 
  104.                                   :window-title "Solar System"
  105.                                   :window-size #@(250 250)
  106.                                   :window-show nil))
  107.   ;;don't show the window until the window is fully initialized
  108.   (have 'center (getf init-list :center))
  109.   (have 'view (getf init-list :view center))
  110.   (center-origin)
  111.   (window-show))
  112.  
  113.  
  114. ;;; The event system will automatically ask windows to handle 
  115. ;;; certain events.   Specialized object functions for handling 
  116. ;;; these events are defined below.
  117.  
  118. (defobfun (window-draw-contents *solar-window*) ()
  119.   "Specialized version of window-draw-contents called by the 
  120.   event system whenever part of the window needs to be redrawn.
  121.   The return value is undefined."
  122.   (declare (object-variable center view x y))
  123.   (erase-window)
  124.   (usual-window-draw-contents)
  125.   (draw-system center (- (ask view x)) (- (ask view y))))
  126.  
  127. (defobfun (window-zoom-event-handler *solar-window*)     
  128.         (message)
  129.   "Specialized version of window-zoom-event-handler which
  130.   is called by the operating system when the user clicks in the
  131.   zoom box.  The MESSAGE is passed on to the 
  132.   usual-window-zoom-event-handler.  This version also recenters 
  133.   the origin.  The return value is undefined."
  134.   (usual-window-zoom-event-handler message)
  135.   (center-origin))
  136.  
  137. (defobfun (set-window-size *solar-window*) (h &optional v)
  138.   "Specialized version of set-window-size.  Sets the size of the 
  139.   window according to horizontal and vertical dimensions, H and V.
  140.   H and V are either two integers or H is taken as a point if V is nil.  
  141.   Also recenters the origin and redraws the window.  Returns the
  142.   window's new size as a point."
  143.   (prog1
  144.     (usual-set-window-size h v)
  145.     (center-origin)
  146.     (window-draw-contents)))
  147.  
  148. (defobfun (center-origin *solar-window*) ()
  149.   "Adjust the origin to the center of the window.  Returns the 
  150.   window's new upper lefthand corner as a point."
  151.   (let ((pt (window-size)))
  152.     (set-origin (floor (point-h pt) -2)
  153.                 (floor (point-v pt) -2))))
  154.  
  155. (defobfun (draw-system *solar-window*) (planet x-off y-off)
  156.   "Draw the PLANET and its satellites in the window after adding 
  157.   X-OFF and Y-OFF to the planet's x and y coordinates.  The return
  158.   value is undefined."
  159.   (declare (object-variable x y size pattern satellites))
  160.   (let ((x0 (+ (ask planet x) x-off))
  161.         (y0 (+ (ask planet y) y-off))
  162.         (size (ask planet size)))
  163.     ;;allocate a temporary rectangle for graphics calls
  164.     (rlet ((rec :rect :top (- x0 size) :left (- y0 size)
  165.                        :bottom (+ x0 size) :right (+ y0 size)))
  166.       (fill-oval (ask planet pattern) rec)
  167.       (frame-oval rec)))
  168.   ;;draw the satellites
  169.   (dolist (sat (ask planet satellites))
  170.     (draw-system sat x-off y-off)))
  171.  
  172. (defobfun (erase-window *solar-window*) ()
  173.   "Erase the contents of the window.  The return value is 
  174.   undefined."
  175.   ;;rref access the Macintosh record and in this case returns 
  176.   ;; the window's portrect.  See the Pearl Lisp documentation 
  177.   ;; for more information about records.
  178.   (declare (object-variable wptr))
  179.   (erase-rect (rref wptr window.portrect)))
  180.  
  181.  
  182. ;;; Menu action functions
  183.  
  184. (defun new-solar (view-planet title)
  185.   "Create a new solar window with VIEW-PLANET determining the 
  186.   point of view and the TITLE string used as base for the window
  187.   title.  The global *solar-num* is incremented and appended to the
  188.   window title to ease identification.  Returns the new window object."
  189.   (setq *solar-num* (+ *solar-num* 1))
  190.   (oneof *solar-window* :window-title 
  191.          (format nil "~A ~A" title *solar-num*)
  192.          :center *sun*
  193.          :view view-planet))
  194.  
  195. (defun exit-solar ()
  196.   "Close all the solar windows and deinstall the menu.  The return 
  197.   value is undefined."
  198.   (dolist (w (windows *solar-window*)) 
  199.     (ask w (window-close)))
  200.   (ask *solar-menu* (menu-deinstall)))
  201.  
  202. (defun run-loop ()
  203.   "Run the simulation until the global *stop-flag* is true.  This
  204.   function also manages the solar menu."
  205.   (setq *stop-flag* nil)
  206.   (ask *stop-item* (set-menu-item-check-mark nil))
  207.   (ask *run-item* (set-menu-item-check-mark t))
  208.   (loop
  209.     (let ((wlist (windows *solar-window*))) 
  210.            ;;list of all *solar-window*'s
  211.       (when (or *stop-flag* (null wlist))   
  212.        ;;check for end of simulation
  213.         (ask *run-item* (set-menu-item-check-mark nil))
  214.         (ask *stop-item* (set-menu-item-check-mark t))
  215.         (return))
  216.       (setq *time* (+ 1 *time*))
  217.       (ask *sun* (update-system *time* 0 0)) 
  218.       ;;updates all the x and y coords
  219.       (dolist (w wlist)
  220.         (ask w (when (ownp 'wptr)   ;protect against close-box
  221.                  (window-draw-contents)))))))   ;redraw the window
  222.  
  223.  
  224. ;;; The menu items
  225.  
  226. (defparameter *new-helio-item* 
  227.   (oneof *menu-item* :menu-item-title "New Helio"
  228.          :menu-item-action '(new-solar *sun* "Heliocentric")))
  229.  
  230. (defparameter *new-geo-item* 
  231.   (oneof *menu-item* :menu-item-title "New Geo"
  232.          :menu-item-action '(new-solar *earth* "Geocentric")))
  233.  
  234. (defparameter *new-luna-item* 
  235.   (oneof *menu-item* :menu-item-title "New Luna"
  236.          :menu-item-action '(new-solar *moon* "Lunacentric")))
  237.  
  238. (defparameter *run-item* 
  239.   (oneof *menu-item* :menu-item-title "Run"
  240.          :menu-item-action '(when *stop-flag* 
  241.                                                      (eval-enqueue '(run-loop)))))
  242.                     
  243. (defparameter *stop-item* 
  244.   (oneof *menu-item* :menu-item-title "Stop"
  245.          :menu-item-action '(setq *stop-flag* t)))
  246.  
  247. (defparameter *exit-item* 
  248.   (oneof *menu-item* :menu-item-title "Exit"
  249.          :menu-item-action 
  250.          '(progn
  251.             (setq *stop-flag* t)
  252.             (eval-enqueue '(exit-solar)))))
  253. ;;The eval-enqueue makes sure that we wait for the run-loop to 
  254. ;; finish before we exit.
  255.  
  256. (defparameter *solar-menu* 
  257.   (oneof *menu* :menu-title "Solar"
  258.          :menu-items (list *new-helio-item*
  259.                            *new-geo-item*      
  260.                            *new-luna-item*
  261.                            (oneof *menu-item* :menu-item-title "-"
  262.                                   :disabled t)
  263.                            *run-item*
  264.                            *stop-item*
  265.                            *exit-item*)))
  266.  
  267.  
  268. ;;; Install the menu
  269. (ask *run-item* (set-menu-item-check-mark (not *stop-flag*)))
  270. (ask *stop-item* (set-menu-item-check-mark *stop-flag*))                          
  271. (ask *solar-menu* (menu-install))
  272.  
  273.  
  274.